home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / YATP102.ZIP / YATP.PAS < prev   
Pascal/Delphi Source File  |  1995-09-05  |  14KB  |  431 lines
  1. PROGRAM YATP; { Free DOS utility: Yet Another "Tree" Program. }
  2. (*   I got much of the code for this program, particularly
  3.      the "DisplayDir" and "ReadFiles" Procedures, from:
  4.    ╔══════════════════════════════════════════════════════╗
  5.    ║  VTree2                                              ║
  6.    ║  Version 1.6, 7-16-90 -- Public Domain by John Land  ║
  7.    ║  (Found in SWAG, in the DIRS library)                ║
  8.    ╚══════════════════════════════════════════════════════╝
  9. *)
  10. {$M 32768,0,655360} { Allow a HUGE stack because of heavy recursion. }
  11. {  ┌────────────────────────────────────────────────────┐
  12.    │ USES AND GLOBAL VARIABLES & CONSTANTS              │
  13.    └────────────────────────────────────────────────────┘  }
  14.  
  15. USES
  16.   Crt, DOS;
  17.  
  18. CONST
  19.   NL        = #13#10;
  20.   NonVLabel = ReadOnly + Hidden + SysFile + Directory + Archive;
  21.   LevelMax  = 16;
  22.  
  23. TYPE
  24.   FPtr      = ^Dir_Rec;
  25.   Dir_Rec   = RECORD                           { Double Pointer Record    }
  26.                 DirName : STRING [14];
  27.                 DirNum  : INTEGER;
  28.                 Next    : Fptr;
  29.               END;
  30.  
  31. VAR
  32.   Dir       : STRING;
  33.   Loop,
  34.   tooDeep   : BOOLEAN;
  35.   Level     : INTEGER;
  36.   Flag      : ARRAY [1..LevelMax] OF STRING [2];
  37.   Filetotal,
  38.   Bytetotal,
  39.   Dirstotal : LONGINT;
  40.   ColorCnt  : WORD;
  41.  
  42.   ClusterSize : WORD;
  43.   TotalClusters : LONGINT;
  44.  
  45. PROCEDURE ShowHelp (CONST problem : BYTE);
  46. (* If any *foreseen* errors arise, we are sent here to
  47.    give a little help and exit (relatively) peacefully *)
  48. CONST
  49.   progdesc = 'YATP v1.02 - Free DOS utility: Yet Another "Tree" Program.';
  50.   author   = 'September 5, 1995.  Copyright (c) 1995 by David Daniel Anderson - Reign Ware.' + NL;
  51.   usage    = 'Usage:  YATP [drive:][\][directory]' + NL;
  52.   notes    = 'Notes:  All parameters are optional; output may be piped or redirected.' + NL;
  53.   examples = 'Examples:' + NL;
  54.   examp1   = '        YATP                   <- all directories below current';
  55.   examp2   = '        YATP c:\               <- all directories on drive C:';
  56.   examp3   = '        YATP d:\os2\           <- only directories below D:\OS2';
  57.   examp4   = '        YATP c:\ | list /s     <- pipe C: tree to LIST' + NL;
  58. VAR
  59.   message : STRING [50];
  60. BEGIN
  61.   WriteLn (progdesc);
  62.   WriteLn (author);
  63.   WriteLn (usage);
  64.   WriteLn (notes);
  65.   WriteLn (examples);
  66.   WriteLn (examp1);
  67.   WriteLn (examp2);
  68.   WriteLn (examp3);
  69.   WriteLn (examp4);
  70.   IF problem > 0 THEN BEGIN
  71.     CASE problem OF
  72.       1 : message := 'Invalid drive or directory.';
  73.       ELSE  message := 'Unanticipated error of unknown type.';
  74.     END;
  75.     WriteLn (#7, message);
  76.   END;
  77.   Halt (problem)
  78. END;
  79.  
  80. FUNCTION Format (Num : LONGINT) : STRING;      {converts Integer to String}
  81. VAR NumStr : STRING;                           {& inserts commas as needed}
  82.   l : SHORTINT;
  83. BEGIN
  84.   Str (Num, NumStr);
  85.   l := (Length (NumStr) - 2);
  86.   WHILE (l > 1) DO BEGIN
  87.     Insert (',', NumStr, l);
  88.     Dec (l, 3);
  89.   END;
  90.   Format := NumStr;
  91. END;
  92.  
  93. FUNCTION OutputRedirected : BOOLEAN;
  94. (* FROM SWAG *)
  95. VAR
  96.   Regs : REGISTERS;
  97.   Handle : WORD ABSOLUTE Output;
  98. BEGIN
  99.   WITH Regs DO
  100.   BEGIN
  101.     AX := $4400;
  102.     BX := Handle;
  103.     MsDos (Regs);
  104.     IF DL AND $82 = $82
  105.       THEN OutputRedirected := FALSE
  106.       ELSE OutputRedirected := TRUE;
  107.   END; {With Regs}
  108. END; {OutputRedirected}
  109.  
  110. PROCEDURE CheckForRedirection;
  111. BEGIN
  112.   IF OutputRedirected THEN BEGIN
  113.     WriteLn ('YATP output has been redirected.');
  114.     Assign (Output, '');
  115.   END
  116.   ELSE
  117.     AssignCrt (Output);
  118.   Rewrite (Output);
  119. END;
  120.  
  121. FUNCTION RTrim (InStr: STRING): STRING;
  122. BEGIN
  123.   WHILE (Length (InStr) > 0) AND (InStr [Length (InStr) ] IN [#0, #9, #32]) DO
  124.     system. Dec (InStr [0]);
  125.   RTrim := InStr;
  126. END;
  127.  
  128. FUNCTION LTrim (InStr: STRING): STRING;
  129. BEGIN
  130.   WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
  131.     Delete (InStr, 1, 1);
  132.   LTrim := InStr;
  133. END;
  134.  
  135. FUNCTION Trim (ss: STRING): STRING;
  136. BEGIN
  137.   Trim := RTrim (LTrim (ss));
  138. END;
  139.  
  140. FUNCTION DirExists (filename: PATHSTR): BOOLEAN;
  141. VAR
  142.   Attr : WORD;
  143.   f    : FILE;
  144. BEGIN
  145.   Assign (f, filename);
  146.   GetFAttr (f, Attr);
  147.   IF (DosError = 0) AND ((Attr AND Directory) = Directory)
  148.     THEN DirExists := TRUE
  149.     ELSE DirExists := FALSE;
  150. END;
  151.  
  152. PROCEDURE ReadParameters;
  153. VAR
  154.   Param   : STRING;
  155. BEGIN
  156.   IF (ParamCount > 1) THEN ShowHelp (0);
  157.   Param := Trim (STRING (Ptr (PrefixSeg, $0080)^));
  158.  
  159.   IF (Pos ('?', Param) <> 0) OR (Pos ('/', Param) <> 0) THEN ShowHelp (0);
  160.  
  161.   Param := FExpand (Param);                    { Set Var to param. String }
  162.   IF Param [Length (Param) ] = '\' THEN
  163.     Dec (Param [0]);                           { Remove trailing backslash}
  164.  
  165.   Dir := Param;
  166.  
  167.   IF (Length (Param) = 2) AND (Param [2] = ':') THEN
  168.     Param := Param + '\';                      {add backslash to test ROOT}
  169.  
  170.   IF NOT DirExists (Param) THEN
  171.     ShowHelp (1);
  172. END;
  173.  
  174. FUNCTION GetClusterSize (drive : BYTE): WORD;  { SWAG routine }
  175. VAR
  176.   regs : REGISTERS;
  177. BEGIN
  178.   regs. CX := 0;         {set for error-checking just to be sure}
  179.   regs. AX := $3600;     {get free space}
  180.   regs. DX := drive;     {0=current, 1=a:, 2=b:, etc.}
  181.   MsDos (regs);
  182.   getclustersize := regs. AX * regs. CX;       {cluster size!}
  183. END;
  184.  
  185. PROCEDURE InitGlobalVars;
  186. BEGIN
  187.   Dir       := '';                             { Init. global Vars.       }
  188.   Loop      := TRUE;
  189.   Level     := 0;
  190.   tooDeep   := FALSE;
  191.   Filetotal := 0;
  192.   Bytetotal := 0;
  193.   Dirstotal := 1;                              { Always have a root dir.  }
  194.   ColorCnt  := 1;
  195.  
  196.   IF ParamCount > 0 THEN
  197.     ReadParameters                             { Deal With any params.    }
  198.   ELSE
  199.     GetDir (0, Dir);
  200.  
  201.   TotalClusters := 0;
  202.   ClusterSize := (GetClusterSize (Ord (UpCase (Dir [1])) - 64));
  203.   IF ClusterSize = 0
  204.   THEN ShowHelp (1);
  205. END;
  206.  
  207. PROCEDURE DisplayHeader;
  208. BEGIN
  209.   TextColor (Cyan);
  210.   WriteLn ('             File size   Files   Directory name');
  211.   WriteLn ('═══════════════════════════════════════════════════════════════════════════════');
  212. END;
  213.  
  214. PROCEDURE CalculateWaste (VAR SR: SEARCHREC);
  215. BEGIN
  216.   IF ((SR. Attr AND Directory) <> Directory)
  217.      AND ((SR. Attr AND VolumeID) <> VolumeID)
  218.   THEN BEGIN
  219.     TotalClusters := TotalClusters + (Sr. Size DIV ClusterSize);
  220.     IF ((Sr. Size MOD ClusterSize) <> 0) THEN Inc (TotalClusters, 1);
  221.   END;
  222. END;
  223.  
  224. PROCEDURE DisplayDir (DirP, DirN : STRING; Levl,
  225.                      NumSubsVar2, SubNumVar2, NumSubsVar3, NmbrFil : INTEGER;
  226.                      FilLen : LONGINT);
  227.  
  228. {NumSubsVar2 is the # of subdirs. in previous level;
  229.  NumSumsVar3 is the # of subdirs. in the current level.
  230.  DirN is the current subdir.; DirP is the previous path}
  231.  
  232. CONST
  233.   Blank    = #32;
  234. VAR
  235.   BegLine,
  236.   WrtStr,
  237.   FlagStr : STRING;
  238.   FlagIndex : BYTE;
  239.  
  240. BEGIN
  241.   BegLine := '';                               { Init. Variables          }
  242.   IF Levl > LevelMax THEN
  243.   BEGIN
  244.     tooDeep := TRUE;
  245.     Exit;
  246.   END;
  247.  
  248.   IF Levl = 0 THEN                             { Special handling For     }
  249.     IF Dir = '' THEN                           { initial (0) dir. level   }
  250.       WrtStr := 'ROOT'
  251.     ELSE
  252.       WrtStr := DirP
  253.   ELSE
  254.   BEGIN                                        { Level 1+ routines        }
  255.     IF SubNumVar2 = NumSubsVar2 THEN           { if last node in subtree, }
  256.     BEGIN                                      { use └─ symbol & set flag }
  257.       BegLine     := '└─';                     { padded With blanks       }
  258.       Flag [Levl] := Blank + Blank;
  259.     END
  260.     ELSE                                       { otherwise, use ├─ symbol }
  261.     BEGIN                                      { & set flag padded With   }
  262.       BegLine     := '├─';                     { blanks                   }
  263.       Flag [Levl] := '│' + Blank;
  264.     END;
  265.  
  266.     FlagStr := '';
  267.     FOR FlagIndex := 1 TO Levl - 1 DO          { Insert │ & blanks as     }
  268.       FlagStr := FlagStr + Flag [FlagIndex];   { needed, based on level   }
  269.     BegLine := FlagStr + BegLine;
  270.  
  271.     WrtStr := BegLine + '──' + DirN;
  272.     IF (NumSubsVar3 <> 0) THEN                 { if cur. level has subs   }
  273.       IF Levl < LevelMax THEN                  { then change to "T" off   }
  274.         WrtStr [Length (BegLine) + 1] := '┬'
  275.       ELSE                                     { if levelMax, special end }
  276.         WrtStr := WrtStr + '─>';               { to indicate more levels  }
  277.   END;                                         { end level 1+ routines    }
  278.  
  279.   IF Odd (ColorCnt) THEN
  280.     TextColor (15)
  281.   ELSE
  282.     TextColor (9);
  283.   Inc (ColorCnt);
  284.  
  285.   WriteLn (Format (FilLen): 22, Format (NmbrFil): 8, '': 3, WrtStr)
  286.                                                { Write # of Files & Bytes  }
  287. END;
  288.  
  289. PROCEDURE ReadFiles (DirPrev, DirNext : STRING;
  290.                      SubNumVar1, NumSubsVar1 : INTEGER);
  291.  
  292. VAR
  293.   FileInfo  : SEARCHREC;
  294.   FileBytes : LONGINT;
  295.   NumFiles,
  296.   NumSubs   : INTEGER;
  297.   Dir_Ptr,
  298.   CurPtr,
  299.   FirstPtr  : FPtr;
  300.  
  301. BEGIN
  302.   FileBytes := 0;
  303.   NumFiles  := 0;
  304.   NumSubs   := 0;
  305.   Dir_Ptr   := NIL;
  306.   CurPtr    := NIL;
  307.   FirstPtr  := NIL;
  308.  
  309.   IF (DirNext = '') AND (DirPrev [Length (DirPrev) ] = '\') THEN
  310.     Dec (DirPrev [0]);                         { Avoid double backslashes }
  311.   IF Loop THEN
  312.     FindFirst (DirPrev + DirNext + '\*.*', NonVLabel, FileInfo);
  313.   Loop      := FALSE;                          { Get 1st File             }
  314.  
  315.   WHILE DosError = 0 DO                        { Loop Until no more Files }
  316.   BEGIN
  317.     IF (FileInfo. Name [1] <> '.') THEN
  318.     BEGIN
  319.       IF ((FileInfo. Attr AND Directory) = Directory) THEN
  320.       BEGIN                                    { if fetched File is dir., }
  321.         New (Dir_Ptr);                         { store a Record With dir. }
  322.         Dir_Ptr^. DirName  := FileInfo. Name;  { name & occurence number, }
  323.         Inc (NumSubs);                         { and set links to         }
  324.         Dir_Ptr^. DirNum   := NumSubs;         { other Records if any     }
  325.         IF CurPtr = NIL THEN
  326.         BEGIN
  327.           Dir_Ptr^. Next := NIL;
  328.           CurPtr        := Dir_Ptr;
  329.           FirstPtr      := Dir_Ptr;
  330.         END
  331.         ELSE
  332.         BEGIN
  333.           Dir_Ptr^. Next := NIL;
  334.           CurPtr^. Next  := Dir_Ptr;
  335.           CurPtr        := Dir_Ptr;
  336.         END;
  337.       END
  338.       ELSE
  339.       BEGIN                                    { Tally # of Bytes in File }
  340.         FileBytes := FileBytes + FileInfo. Size;
  341.         CalculateWaste (FileInfo);
  342.         Inc (NumFiles);                        { Increment # of Files,    }
  343.       END;                                     { excluding # of subdirs.  }
  344.     END;
  345.     FindNext (FileInfo);                       { Get next File            }
  346.   END;    {end While}
  347.  
  348.   Bytetotal := Bytetotal + FileBytes;
  349.   Filetotal := Filetotal + NumFiles;
  350.   Dirstotal := Dirstotal + NumSubs;
  351.  
  352.   DisplayDir (DirPrev, DirNext, Level, NumSubsVar1, SubNumVar1,
  353.   NumSubs, NumFiles, FileBytes);               { Pass info to & call      }
  354.   Inc (Level);                                 { display routine, & inc.  }
  355.                                                { level number             }
  356.  
  357.   WHILE (FirstPtr <> NIL) DO                   { if any subdirs., then    }
  358.   BEGIN                                        { recursively loop thru    }
  359.     Loop     := TRUE;                          { ReadFiles proc. til done }
  360.     ReadFiles ((DirPrev + DirNext + '\'), FirstPtr^. DirName,
  361.     FirstPtr^. DirNum, NumSubs);
  362.     FirstPtr := FirstPtr^. Next;
  363.   END;
  364.                                                { Decrement level when     }
  365.   Dec (Level);                                 { finish a recursive loop  }
  366.                                                { call to lower level of   }
  367. END;                                           { subdir.                  }
  368.  
  369. PROCEDURE WriteDriveInfo;
  370. VAR DS, DF : LONGINT;   {bytes of *partition* space Size/Free}
  371.   Disk : BYTE;
  372.   Percent : STRING[6];
  373. BEGIN
  374.   Disk := (Ord (UpCase (Dir [1])) - 64);
  375.  
  376.   DS := DiskSize (Disk);
  377.   IF (DS < 0) THEN BEGIN
  378.     DS := 0;
  379.     DF := 0;
  380.   END
  381.   ELSE
  382.     DF := DiskFree (Disk);
  383.  
  384.   IF DS = 0
  385.   THEN Percent := ('0.00')
  386.   ELSE Str ((100 * (DF / DS)): 0: 2, Percent);
  387.  
  388.   WriteLn ('Free:  ', Format (DF): 15,
  389.            ' bytes out of ', Format (DS),
  390.            ' (', percent, '% of drive is unused)');
  391. END;
  392.  
  393. PROCEDURE DisplayTally;
  394. VAR
  395.   WasteSpace,
  396.   TotalSpace  : LONGINT;
  397. BEGIN
  398.   TextColor (Cyan);
  399.   WriteLn ('═══════════════════════════════════════════════════════════════════════════════');
  400.   WriteLn ('Totals:', Format (Bytetotal): 15, Format (Filetotal): 8, '(': 4, Dirstotal, ' directories)');
  401.  
  402.   TotalSpace := (TotalClusters * ClusterSize);
  403.   WasteSpace := (TotalSpace - Bytetotal);
  404.   WriteLn ('Using: ', Format (TotalSpace): 15,
  405.   ' bytes altogether (based on ', ClusterSize, ' bytes per cluster)');
  406.   Write   ('Making:', Format (WasteSpace): 15, ' bytes wasted (');
  407.   IF Bytetotal = 0
  408.     THEN Write ('0.00')
  409.     ELSE Write (100 * (WasteSpace / TotalSpace): 0: 2);
  410.   WriteLn ('% of the space used is wasted)');
  411.  
  412.   WriteDriveInfo;
  413. END;
  414.  
  415. {┌────────────────┐
  416.  ├─ Main Program ─┤
  417.  └────────────────┘ }
  418. BEGIN
  419.   ClrScr;
  420.   CheckForRedirection;                         { Get ready ...            }
  421.   InitGlobalVars;                              { Get set ...              }
  422.   DisplayHeader;                               { Display Header           }
  423.   ReadFiles (Dir, '', 0, 0);                   { Go! do main read routine }
  424.   DisplayTally;                                { Display totals           }
  425.   IF tooDeep THEN
  426.     WriteLn (NL, NL, '': 21,
  427.               '» CANNOT DISPLAY MORE THAN ', LevelMax, ' LEVELS «', NL);
  428.                                                { if ReadFiles detects > 16}
  429.                                                { levels, tooDeep flag set }
  430. END.                                           { Finish.                  }
  431.